Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / nojet / main.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-03-11 | 30.9 KB | 940 lines

VERSION 2.00 Begin Form frmMain AutoRedraw = -1 'True BackColor = &H8000000F& BorderStyle = 3 'Fixed Double Caption = "Contact Database" ClientHeight = 5490 ClientLeft = 1035 ClientTop = 1440 ClientWidth = 8835 ClipControls = 0 'False FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 5925 Icon = MAIN.FRX:0000 Left = 960 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 5490 ScaleWidth = 8835 Top = 1080 Width = 8985 Begin PictureClip picClip Cols = 4 Location = "1140,720,4140,7560" Picture = MAIN.FRX:0302 Rows = 3 End Begin PictureBox picDataCtl AutoRedraw = -1 'True BackColor = &H8000000F& ClipControls = 0 'False Height = 270 Left = 3840 ScaleHeight = 240 ScaleWidth = 1125 TabIndex = 36 Top = 4980 Width = 1155 Begin Image imgDataCtl Enabled = 0 'False Height = 240 Index = 0 Left = 0 Top = 0 Width = 285 End Begin Image imgDataCtl Enabled = 0 'False Height = 240 Index = 1 Left = 285 Top = 0 Width = 285 End Begin Image imgDataCtl Enabled = 0 'False Height = 240 Index = 2 Left = 555 Top = 0 Width = 285 End Begin Image imgDataCtl Enabled = 0 'False Height = 240 Index = 3 Left = 840 Top = 0 Width = 285 End End Begin CommandButton cmdButton Cancel = -1 'True Caption = "&Find" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Index = 4 Left = 7260 TabIndex = 20 Top = 2040 Width = 1335 End Begin CommandButton cmdButton Caption = "&Delete" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Index = 3 Left = 7260 TabIndex = 19 Top = 1590 Width = 1335 End Begin CommandButton cmdButton Caption = "&New" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Index = 2 Left = 7260 TabIndex = 18 Top = 1140 Width = 1335 End Begin Ctl3D Ctl3D ClassList = MAIN.FRX:0AFC IgnoreColors = -1 'True Left = 8280 No3DMenus = -1 'True Top = 4920 End Begin CommandButton cmdButton Caption = "Save" Default = -1 'True FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Index = 0 Left = 7260 TabIndex = 16 Top = 240 Width = 1335 End Begin CommandButton cmdButton Caption = "Cancel" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Index = 1 Left = 7260 TabIndex = 17 Top = 690 Width = 1335 End Begin TextBox txtCustData DataField = "E-Mail" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 13 Left = 1230 MaxLength = 30 TabIndex = 14 Top = 4350 Width = 1935 End Begin TextBox txtCustData DataField = "Country" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 9 Left = 5355 MaxLength = 30 TabIndex = 10 Top = 2325 Width = 1605 End Begin TextBox txtCustData DataField = "Zip" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 8 Left = 4140 MaxLength = 10 TabIndex = 9 Top = 2325 Width = 1125 End Begin TextBox txtCustData DataField = "State" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 7 Left = 2925 MaxLength = 30 TabIndex = 8 Top = 2325 Width = 1125 End Begin TextBox txtCustData DataField = "Address 1" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 4 Left = 1230 MaxLength = 30 TabIndex = 5 Top = 1725 Width = 2820 End Begin TextBox txtCustData DataField = "Address 2" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 5 Left = 4140 MaxLength = 30 TabIndex = 6 Top = 1725 Width = 2820 End Begin TextBox txtCustData DataField = "Fax" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 12 Left = 1230 MaxLength = 15 TabIndex = 13 Top = 3750 Width = 1935 End Begin ComboBox cboCustData FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Left = 300 TabIndex = 0 Top = 525 Width = 760 End Begin TextBox txtCustData DataField = "Extension" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 11 Left = 2520 MaxLength = 10 TabIndex = 12 Top = 3150 Width = 645 End Begin TextBox txtCustData DataField = "Title" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 3 Left = 4140 MaxLength = 30 TabIndex = 4 Top = 1125 Width = 2820 End Begin TextBox txtCustData DataField = "Company" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 2 Left = 1230 MaxLength = 30 TabIndex = 3 Top = 1125 Width = 2820 End Begin TextBox txtCustData DataField = "Comment" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 1500 Index = 14 Left = 3315 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 15 Top = 3150 Width = 3660 End Begin TextBox txtCustData DataField = "City" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 6 Left = 1230 MaxLength = 30 TabIndex = 7 Top = 2325 Width = 1605 End Begin TextBox txtCustData DataField = "Phone" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 10 Left = 1230 MaxLength = 15 TabIndex = 11 Top = 3150 Width = 1200 End Begin TextBox txtCustData DataField = "First Name" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 1 Left = 2925 MaxLength = 20 TabIndex = 2 Top = 525 Width = 1125 End Begin TextBox txtCustData DataField = "Last Name" DataSource = "datCtl" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 300 Index = 0 Left = 1230 MaxLength = 30 TabIndex = 1 Top = 525 Width = 1605 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "E-Mail:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 13 Left = 1230 TabIndex = 35 Top = 4110 Width = 480 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Country:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 9 Left = 5355 TabIndex = 21 Top = 2085 Width = 585 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Zip:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 8 Left = 4140 TabIndex = 34 Top = 2085 Width = 270 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "State:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 7 Left = 2925 TabIndex = 33 Top = 2085 Width = 420 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Address 2:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 5 Left = 4140 TabIndex = 32 Top = 1485 Width = 750 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Fax:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 12 Left = 1230 TabIndex = 31 Top = 3510 Width = 300 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Ext:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 11 Left = 2520 TabIndex = 30 Top = 2910 Width = 270 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Title:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 3 Left = 4140 TabIndex = 29 Top = 885 Width = 345 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Company:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 2 Left = 1230 TabIndex = 28 Top = 885 Width = 705 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Comments:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 14 Left = 3315 TabIndex = 27 Top = 2910 Width = 780 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "City:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 6 Left = 1230 TabIndex = 26 Top = 2085 Width = 300 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Phone:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 10 Left = 1230 TabIndex = 25 Top = 2910 Width = 510 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "First Name:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 1 Left = 2925 TabIndex = 24 Top = 300 Width = 795 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Last Name:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 0 Left = 1230 TabIndex = 23 Top = 300 Width = 810 End Begin Label lblCustData AutoSize = -1 'True BackColor = &H8000000F& Caption = "Address 1:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 4 Left = 1230 TabIndex = 22 Top = 1485 Width = 750 End DefInt A-Z Option Explicit Const MODAL = 1 'Flags var & constants Dim iFlags As Integer Const FL_DATACHANGED = 1 Const FL_KEYCHANGED = 2 'Index pointer Dim lRecNo As Long 'User-defined types Dim udtContact As Contact Dim udtComment As Comment Dim udtIndex As ContactIndex Sub cmdButton_Click (Index As Integer) Dim lResult As Long Dim sFName As String Dim sLName As String Dim sTarget As String Dim udtTemp As Contact Select Case Index Case 0 'Save If (iFlags And FL_DATACHANGED) Then Call ContactSave(lRecNo) iFlags = iFlags And (Not FL_DATACHANGED) End If Case 1 'Cancel 'Force lRecNo positive ' (cancels AddNew if pending) lRecNo = Abs(lRecNo) 'Refresh current record from file ' (cancel changes) Call ContactDisplay(lRecNo) 'Clear flags iFlags = iFlags And (Not FL_DATACHANGED) iFlags = iFlags And (Not FL_KEYCHANGED) Case 2 'New 'Clear UDT LSet udtContact = udtTemp 'Negative rec no means we're ' adding a new one lRecNo = -(lRecNo) Call ContactDisplay(lRecNo) Case 3 'Delete If (udtContact.Link > 0) Then Call CommentDelete(udtContact.Link) End If Call ContactDelete(lRecNo) Call IndexDelete(lRecNo) Call ContactDisplay(lRecNo) Case 4 'Find frmSearch.Show MODAL 'If user pressed 'OK'... If Val(frmSearch.Tag) = 0 Then sLName = RTrim$(frmSearch!txtCustData(0) & sNull) sFName = RTrim$(frmSearch!txtCustData(1) & sNull) 'If user entered a first name... If Len(sFName) Then 'Use udtTemp to pad last name udtTemp.LastName = sLName 'Concatentate first name sTarget = udtTemp.LastName & sFName Else '...otherwise, just search on ' last name sTarget = sLName End If lResult = IndexSearch(sTarget) If lResult Then lRecNo = lResult Call ContactDisplay(lRecNo) Else Beep End If End If Unload frmSearch End Select Call NavBtnUpdate(lRecNo) End Sub Sub ContactDisplay (lRecNo As Long) If lRecNo > 0 Then 'Get lRecNo from index and then ' retrieve the contact it points to Get hIdx, lRecNo, udtIndex Get hDat, udtIndex.lRecNo, udtContact End If cboCustData.Text = RTrim$(udtContact.Salutation) txtCustData(0).Text = RTrim$(udtContact.LastName) txtCustData(1).Text = RTrim$(udtContact.FirstName) txtCustData(2).Text = RTrim$(udtContact.Company) txtCustData(3).Text = RTrim$(udtContact.Title) txtCustData(4).Text = RTrim$(udtContact.Address_1) txtCustData(5).Text = RTrim$(udtContact.Address_2) txtCustData(6).Text = RTrim$(udtContact.City) txtCustData(7).Text = RTrim$(udtContact.State) txtCustData(8).Text = RTrim$(udtContact.ZipCode) txtCustData(9).Text = RTrim$(udtContact.Country) txtCustData(10).Text = RTrim$(udtContact.Phone) txtCustData(11).Text = RTrim$(udtContact.Extension) txtCustData(12).Text = RTrim$(udtContact.Fax) txtCustData(13).Text = RTrim$(udtContact.EMail) 'Is there an associated comment? If udtContact.Link > 0 Then 'If so, show it Get hCmt, udtContact.Link, udtComment txtCustData(14).Text = RTrim$(udtComment.Text) Else 'Otherwise, clear text box txtCustData(14).Text = sNull End If End Sub Sub ContactSave (lRecNo As Long) Dim sTemp As String 'Get comment from text box sTemp = Trim$(txtCustData(14).Text) 'If there's a comment... If Len(sTemp) Then '...and there wasn't one before... If udtContact.Link < 1 Then 'Get next available record number udtContact.Link = FreeComment&(hCmt) End If '...otherwise use existing record udtComment.Text = sTemp Put hCmt, udtContact.Link, udtComment Else 'If there's no comment, but there was ' one when we started... If udtContact.Link > 0 Then 'Delete existing comment Call CommentDelete(udtContact.Link) 'Clear record pointer udtContact.Link = 0 End If End If udtContact.Salutation = cboCustData.Text udtContact.LastName = txtCustData(0).Text udtContact.FirstName = txtCustData(1).Text udtContact.Company = txtCustData(2).Text udtContact.Title = txtCustData(3).Text udtContact.Address_1 = txtCustData(4).Text udtContact.Address_2 = txtCustData(5).Text udtContact.City = txtCustData(6).Text udtContact.State = txtCustData(7).Text udtContact.ZipCode = txtCustData(8).Text udtContact.Country = txtCustData(9).Text udtContact.Phone = txtCustData(10).Text udtContact.Extension = txtCustData(11).Text udtContact.Fax = txtCustData(12).Text udtContact.EMail = txtCustData(13).Text If (lRecNo < 1) Then 'We're adding a new record udtIndex.sKey = udtContact.LastName & udtContact.FirstName udtIndex.lRecNo = FreeContact&(hDat) Call IndexInsert(udtIndex) 'Set lRecNo to point at new record lRecNo = IndexSearch(udtIndex.sKey) ElseIf (iFlags And FL_KEYCHANGED) Then 'Get existing index rec for this contact Get hIdx, lRecNo, udtIndex 'Delete old index entry Call IndexDelete(lRecNo) 'Create new key and add it to index (without ' changing the contact record to which it points) udtIndex.sKey = udtContact.LastName & udtContact.FirstName Call IndexInsert(udtIndex) 'Set current rec ptr to new index entry lRecNo = IndexSearch(udtIndex.sKey) 'Clear the flag iFlags = iFlags And (Not FL_KEYCHANGED) End If 'Save contact record Put hDat, udtIndex.lRecNo, udtContact End Sub Sub Form_Load () Dim I As Integer 'Populate cboCustData with ' salutations... cboCustData.AddItem "Mr." cboCustData.AddItem "Mrs." cboCustData.AddItem "Ms." cboCustData.ListIndex = 0 'Open files hDat = FileOpen(AppPath$() & "contacts.dat", Len(udtContact)) hIdx = FileOpen(AppPath$() & "contacts.idx", Len(udtIndex)) hCmt = FileOpen(AppPath$() & "comments.dat", Len(udtComment)) If lRecNo = 0 Then lRecNo = 1 Call ContactDisplay(lRecNo) Call NavBtnUpdate(lRecNo) 'Define global strings sNull = "" End Sub Sub Form_Unload (Cancel As Integer) Close End End Sub Sub imgDataCtl_MouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If (Button And 1) Then imgDataCtl(Index).Picture = PicClip.GraphicCell(Index + 4) End If End Sub Sub imgDataCtl_MouseUp (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lRecs As Long 'Save current record if it has changed If (iFlags And FL_DATACHANGED) Then Call ContactSave(lRecNo) iFlags = iFlags And (Not FL_DATACHANGED) End If imgDataCtl(Index).Picture = PicClip.GraphicCell(Index) lRecs = LOF(hIdx) \ Len(udtIndex) Select Case Index Case 0 lRecNo = 1 Case 1 lRecNo = lRecNo - 1 Case 2 lRecNo = lRecNo + 1 Case 3 lRecNo = lRecs End Select Call ContactDisplay(lRecNo) Call NavBtnUpdate(lRecNo) End Sub Sub NavBtnUpdate (lRecNo As Long) Dim I As Integer Dim lRecs As Long 'Enable/disable "data control" buttons based on ' lRecNo's relation to number of recs in database lRecs = LOF(hIdx) \ Len(udtIndex) 'Load "data control" with greyed-out buttons ' (they're disabled by default) For I = 0 To 3 imgDataCtl(I).Enabled = False imgDataCtl(I).Picture = PicClip.GraphicCell(I + 8) Next If lRecNo > 1 Then 'Enable leftward navigation buttons For I = 0 To 1 imgDataCtl(I).Enabled = True imgDataCtl(I).Picture = PicClip.GraphicCell(I) Next End If If lRecNo < lRecs Then 'Enable rightward navigation buttons For I = 2 To 3 imgDataCtl(I).Enabled = True imgDataCtl(I).Picture = PicClip.GraphicCell(I) Next End If End Sub Sub txtCustData_KeyPress (Index As Integer, KeyAscii As Integer) iFlags = iFlags Or FL_DATACHANGED If (Index = 0) Or (Index = 1) Then iFlags = iFlags Or FL_KEYCHANGED End If End Sub